perm filename SLURXG.FAI[NEW,LCS] blob
sn#469454 filedate 1979-08-24 generic text, type T, neo UTF8
TITLE SLURXG
ENTRY SLUR
EXTERNAL .COMM.,PLTR,ALF,SSS,SLR,PTR,LIMIT,STF
SLUR: 0 ; SUBROUTINE SLUR
MOVEI 1,1 ; IMPLICIT INTEGER(A-Q,T-Z)
MOVEM 1,.COMM.+=31;COMMON /ALF/INP,SLURY(72) /SSS/ SSS(200) /SLR/ SLURX(1)
SETZM .COMM.+=25 ; REAL CENTR
MOVEI 5,5 ; COMMON /PLTR/PLT,RHT,RDIS,XDIS
MOVEM 5,.COMM.+=15; COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
SETOM TWICE# ; 1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
SKIPL PLTR ; 1 J5,J6,J7,J8,J9,J10,J11,JQ(7),R,RJ
JRST S21 ;1 /PTR/PWDS(1) /LIMIT/LIMIT,ITEM,L,I,IX /STF/RSTFAC(0/7),RSTJ2
SETZM TWICE ;CF; DATA RZZ/2.8/
MOVEM 1,.COMM.+=15 ;KQ C DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8
MOVE 3,[0.2] ;2 J10=1
MOVE PLTR+1 ; J4=0
CAMGE [2.0] ; KQ=5
JRST S21 ; TWICE=-1
MOVEM 1,TWICE ;C -1 FOR DISPLAY, USES ONLY 1/3 OF SEGMENTS
MOVE 3,[0.14] ; IF(PLT.GE.0)GO TO 21
CAMGE [3.0] ; TWICE=0
JRST S21 ; KQ=1
ADDM 1,TWICE ; RWID=.2
MOVE 3,[0.1] ; IF(RHT.LT.2)GO TO 21
S21: MOVEM 3,RWID# ; TWICE=1
MOVE STF+=8 ; RWID=.14
FMPR [7.0] ;C IF SIZE IS GT.2 3 SLURS ARE DRAWN
MOVEM RST7 ; IF(RHT.LT.3)GO TO 21
MOVE 6,.COMM.+6 ;R5
FSBR 6,.COMM.+5 ;-R4 AC6 IS RQQ
MOVE .COMM.+7 ; TWICE=2
CAMG [1000.0] ;C IF SIZE IS GE.3 4 SLURS ARE DRAWN
JRST .+3 ; RWID=.1
JSA 16,RNOTE ;21 RST7=RSTJ2*7.
.COMM.+7 ; RQQ=R5-R4
MOVN 8,.COMM.+=29 ; IF(R6.GT.1000)CALL RNOTE(R6)
CAIN 8,1 ; GO TO (5,6,7),J8+4
JRST S7 ;(J8=-1) GO TO 4
CAIN 8,2 ;5 R=30
JRST S6 ;CC5; R=32
CAIE 8,3 ;C AFTER DOTTED NOTE
JRST S4 ; GO TO 8
S5: MOVE [30.0] ;CC6; R=18
JRST S8 ;6 R=22
S6: MOVE [22.0] ;C BETWEEN NOTES
S8: MOVN 2,[0.75] ;8 RX=-0.75
JRST S9 ;CC8; RX=-1.3
S7: MOVE [7.0] ; GO TO 9
MOVE 2,STF+=8 ;7 R=7
S9: FMPR STF+=8 ; RX=RSTJ2
FADRM .COMM.+=4
FADRB 2,.COMM.+7 ;9 CALL RJBX(R)
S4: FMPR 2,[5.96] ; R6=R6+RX
FSBR 2,[596.0] ;4 RXX=RHORZ(R6)-R3
FSBR 2,.COMM.+4 ;AC2=RXX RTILT=RQQ*RST7
MOVE 3,6 ;GET RQQ
FMPR 3,RST7
MOVEM 3,RTILT
FMPR 3,3
FMPR 2,2
FADR 3,2
JSA 16,SQRT ;80 RX=SQRT(RXX*RXX+RTILT*RTILT)
3
MOVEM RX
CAIE 8,1 ; IF(J8.NE.-1)GO TO 10
JRST S10
CAMLE 6,[8.0] ; IF(RQQ.GT.8)RQQ=8
MOVE 6,[8.0]
CAMGE 6,[-8.0] ; IF(RQQ.LT.-8)RQQ=-8
MOVE 6,[-8.0] ;CCCC; RQQ=RQQ*RSTFAC(J2)
SKIPGE .COMM.+=8 ; IF(R7)RQQ=-RQQ
MOVNS 6
; R3=R3-RQQ*RSTJ2
;CCC; R3=R3-RQQ
; MOVES STEEP SLUR LEFT OR RIGHT IF P8=-1
;10 RJ=ABS(R7)
; R7+100=LEFT HALF SLUR, +200=RIGHT HALF, +300=REVERSE DIRECTION.
; IF(RJ.LT.100)RJ=-1
; IF(RJ.GE.300)RJ=0
; R7=AMOD(R7,100.0)
; R=RDIS*RX*.4
; L=R
; L=L*2
C TO INSURE AN EVEN NUMBER OF VECTORS (ONLY 1/2 ARE COMPUTED IN SLOOP)
; IF(L.LT.60)L=60
; IF(L.GT.272)L=272
; IF(J11.EQ.0)GO TO 1
; R=R*2
; RZ=L-60
; J11=RZ * 10./212. +7.
; RXXX=.02
111; IF(R.GT.272)J11=J11-RXXX*(R-272)
; IF(J11.LT.7)J11=7
11; IF(MOD(L/J11,2).NE.0)GO TO 1
C TO INSURE AN UNEVEN NUMBER OF SEGMENTS (SO THE LAST IS BLACK)
; J11=J11+1
; GO TO 11
CC; J11=R/7.
CC; IF(J11.LT.7)J11=7
CC; IF(J11.GT.39)J11=39
CC; J11=RDIS*L/J11
C FOR DASHED SLURS
C L=NUMB OF SEGMENTS IN THE CURVE.
1; R=CENTR
; IF(J8.GT.0)GO TO 180
C JUMP FOR BRACKETS
; CALL SLOOP
; IF(J4.NE.0)GO TO 83
87; CALL LINES(SLURX(J10),SLURY(J10),3)
; IF(J11.EQ.0)J4=-1
83; J5=KQ
; J6=J10
; J7=L
; IF(J11.NE.0)GO TO 122
; IF(J4)GO TO 22
; J6=L
; J7=J10
; J5=-1
22; DO 88 K=J6,J7,J5
88; CALL LINES(SLURX(K),SLURY(K),2)
; GO TO 123
122; KD=2
; KT=0
; KA=1
C THIS WILL MAKE DASHED SLURS J11 HAS DASH SIZE.
; DO 188 K=J6,J7,J5
; KT=KT+1
; IF(KT.LT.J11)GO TO 188
; KT=0
; KD=KD+KA
; KA=-KA
C BLANK-DASH FLIP-FLOP
188; CALL LINES(SLURX(K),SLURY(K),KD)
123; IF(J5.GT.1)CALL LINES(SLURX(L),SLURY(L),2)
; IF(TWICE)RETURN
; TWICE=TWICE-1
; IF(J8.GT.0)GO TO 182
; J4=-J4
; R7=R7+RWID
C RWID=WIDTH OF SLUR -- SEE DATA
; GO TO 1
180; RW=R+R7*RST7
; TWICE=-1
; KQ=1
; RX=RX+R3
CC; RA=(R5-R4)*RST7
; IF(J9.EQ.0)GO TO 181
; TWICE=2
; RZ=RTILT/(RX-R3)
; RXX=RX
; RWID=(R3+RXX)/2.
182; IF(TWICE.EQ.1)GO TO 183
C DOES LEFT SIDE FIRST.
; IF(TWICE.EQ.0)GO TO 184
C LAST IS NUMBER.
; J8=2
; RC=RSTJ2*13.
; RX=RWID-RC
; RWW=RTILT
185; RTILT=RZ*(RX-R3)
C PUT IN FUNC. HERE FOR THIS SLOPE AND FOR PART. BEAMS.
; GO TO 181
183; J8=3
; RX=RXX
; RTILT=RWW
; RXX=R3
; R3=RWID+RC
; RXX=RZ*(R3-RXX)
; R=R+RXX
; RW=RW+RXX
; GO TO 185
181; SLURX(1)=R3
; SLURY(1)=R
; SLURX(2)=R3
; SLURY(2)=RW
; SLURX(3)=RX
; SLURY(3)=RW+RTILT
; SLURX(4)=RX
; SLURY(4)=R+RTILT
; L=4
; IF(J8.EQ.2)L=3
; IF(J8.EQ.3)J10=2
CC; TWICE=-1
; GO TO 87
184; J3=RWID
C PUT IN VERT. POS. WHEN SLOPE!
; R4=RQQ/2.+R4+R7-1.
; R6=0.875
C .875 IS SIZE OF NUM. R7=1 MAKES ITALIC FONT
; R7=1.
; R8=0
; CALL MAKNUM(R9)
; END
C 8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY